Final Project
Ashley L. Miller
1/28/2019
The following dataset is de-identified and already hosted on Github. The data come from one of my recent publications (Experiment 1; Miller, Gross, & Unsworth, 2019). In this paper, pupil dilation was used as an online indicator of the intensity of attention to determine whether variation in attention at encoding relates to individual differences in working memory capacity (WMC) and long-term memory (LTM) performance. Participants (N = 138) completed a battery of complex span working memory tasks, followed by a delayed free recall task while pupil dilation was simultaneously recorded.
data <- import(here("data", "DeIntentifiedJML2019Data_Exp1.sav"),
setclass = "tibble") %>%
characterize() %>%
janitor::clean_names()# Select variables of interest for pupil data
pupil_data <- data %>%
select(-sp1_acc:-symspan,
-ineffective:-recency_recall,
-baseline_pupil_mean:-tepr_recency)
# Cam's efficient method to rename bin/word variables
# E.g., data currently reads ebin1w1pt4_mean
# I just want the variable to read bin1w1
pupil_data %<>%
rename_at(
vars(starts_with("ebin")),
funs(
paste(
str_extract(., "w\\d{1,2}"),
"_",
str_extract(., "bin\\d{1,2}"),
sep = "")))Please note that for the following figures, I specified dimensions appropriate for a knitted html document. Also, just a heads up that it will probably take at least 5 minutes to generate the html because of the animated plots!
Plot 1
Here I plot changes in pupil diameter across the 3 second study/encoding phase for each word (i.e., bin).
- Fig. 4 in Miller, Gross, & Unsworth (2019).
- Identification of the intended audience: Scientific community
- The intended message to be communicated: When instructed to study a list of words, pupil diameter increases throughout the study phase for each word. This increase in pupil dilation is believed to reflect an increase in the amount of attentional effort devoted to a given item.
# Tidy data:
plot1_data <- pupil_data %>%
gather(key = word_bin, value = TEPR, w1_bin1:w10_bin15) %>%
separate(word_bin, c("word", "bin"), sep = "_") %>%
mutate(word = parse_number(word),
bin = parse_number(bin)) %>%
arrange(subject)
#glimpse(plot1_data)plot1 <- plot1_data %>%
group_by(bin) %>%
summarise(mean_TEPR = mean(TEPR, na.rm = TRUE),
se_TEPR = sundry::se(TEPR))
# This just makes the line begin at x = 0 and y = 0
plot1 <- rbind(plot1, "1st" = c(0, 0, 0))
# I want to model uncertainty with bootstrapping:
row_samps <- rerun(100,
sample(seq_len(nrow(plot1)),
nrow(plot1),
replace = TRUE))
# Extracting samples
d_samps <- map_df(row_samps, ~plot1[., ], .id = "sample")
# Plotting both data sources (my data and hypothetical/bootstrapped data)
plot1 <- ggplot(plot1, aes(x = bin, y = mean_TEPR)) +
stat_smooth(aes(group = sample),
data = d_samps,
geom = "line",
color = "#2DDADA",
fullrange = TRUE,
size = 0.1) +
theme_minimal() +
# Bold title and axes; left-align caption
theme(axis.title = element_text(face = "bold"),
plot.title = element_text(face = "bold"),
plot.caption = element_text(hjust = 0)) +
# Change labels
labs(caption = "Figure 1. Task evoked pupillary response across the 3 second study (encoding) phase for each word",
y = "Mean Pupil Diameter (mm)",
x = "Time (ms)") +
# Relabel x axis values to make more sense to reader
scale_x_continuous(breaks = c(0, 1, 2, 3, 4, 5, 6, 7, 8,
9, 10, 11, 12, 13, 14, 15),
labels = c("0", "200", "400", "600", "800", "1,000",
"1,200", "1,400", "1,600", "1,800", "2,000",
"2,200", "2,400", "2,600", "2,800", "3,000"),
limits = c(0, NA)) +
# Add text specifying when stimuli appear onscreen
geom_text(y = 0.04,
x = 1.4,
color = "gray80",
label = " To-be-remembered
word appears onscreen", size = 3, fontface = 2) +
# Add dotted vertical line at x = 0
geom_vline(aes(xintercept = 0),
color = "gray80",
lty = "dashed")
# Creating my own theme
bbg_darktheme <- theme(panel.grid.major = element_line(colour = "gray20"),
panel.grid.minor = element_line(colour = "gray20"),
axis.text = element_text(colour = "gray80"),
axis.text.x = element_text(colour = "gray80"),
axis.text.y = element_text(colour = "gray80"),
axis.title = element_text(colour = "gray80", face = "bold"),
legend.text = element_text(colour = "gray80"),
legend.title = element_text(colour = "gray80"),
plot.subtitle = element_text(colour = "gray80"),
strip.text = element_text(colour = "gray80", face = "bold"),
panel.background = element_rect(fill = "gray10"),
plot.background = element_rect(fill = "gray10"),
legend.background = element_rect(fill = NA, color = NA),
plot.margin = margin(10, 10, b = 20, 10),
plot.caption = element_text(colour = "gray80", vjust = 1),
plot.title = element_text(colour = "gray80", face = "bold"))
# Apply my theme to plot
plot1 + bbg_darktheme
Plot 2
Here I plot pupil diameter as a function of serial position for high WMC (n = 33), medium WMC (n = 69) and low WMC (n = 31) individuals.
- Fig. 5 in Miller, Gross, & Unsworth (2019)
- Identification of the intended audience: Scientific community
- The intended message to be communicated: Different patterns of pupil dilation across serial positions emerge based on one’s working memory capacity (WMC). Namely, for high WMC individuals (n = 33), pupil diameter increases as each new word is introduced during the learning phase of the task. Alternatively, for low WMC individuals (n = 31), pupil diameter decreases as each new word is introducted during learning.
#Reordering factor levels for legend
plot1_data$span_group <- factor(plot1_data$span_group,
levels = c("Low", "Medium", "High"))
plot2data <- plot1_data %>%
group_by(word, span_group) %>%
summarise(mean_TEPR = mean(TEPR, na.rm = TRUE),
se_TEPR = sundry::se(TEPR))
# Rename variable for legend
plot2data %<>%
rename("WMC" = `span_group`)
plot2 <- ggplot(plot2data, aes(x = word, y = mean_TEPR)) +
geom_ribbon(aes(ymin = mean_TEPR - 1.96*se_TEPR,
ymax = mean_TEPR + 1.96*se_TEPR,
fill = WMC),
alpha = 0.4) +
scale_fill_carto_d(palette = "Burg") +
theme_minimal() +
# Left-align caption
theme(plot.caption = element_text(hjust = 0)) +
# Change labels
labs(caption = "Figure 2. Pupillary response across serial positions for low working memory capacity (WMC) individuals
(n = 31), medium WMC individuals (n = 69), and high WMC individuals (n = 33).",
y = "Mean Pupil Diameter (mm)",
x = "Serial position",
colour = "WMC") +
# Relabel x axis values to make more sense to reader
scale_x_continuous(breaks = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10),
labels = c("1", "2", "3", "4", "5",
"6", "7", "8", "9", "10"))
plot2 + bbg_darktheme
Plot 3
Now I will attempt to plot pupil diameter as a function of serial position (broken down into Primacy (words 1–3), Mid (words 4–7), and Recency (words 8–10)) and bin (time across the 3 second study phase for each word) based on one’s WMC.
- Fig. 6 in Miller, Gross, & Unsworth (2019)
- Identification of the intended audience: Scientific community
- The intended message to be communicated: This figure essentially conveys the same information as the figure above. For high WMC individuals, pupil dilation continues to gradually increase throughout the encoding period for all serial positions, with primacy items (the first few words presented during list presentation; words 1-3) displaying smaller dilations than mid (words 4–7) and recency items (the last few words presented during list presentation; words 8–10). Conversely, low WMC individuals show moderate increases in dilation that appear to plateau near the middle of the encoding period. Moreover, pupil dilation appears to be largest for primacy items and smallest for recency items, despite a gradual increase in dilation for recency items.
# Converting word # to factors
plot1_data$word <- as.factor(plot1_data$word)
# Breaking down words into primacy, mid, and recency items
plot3_data <- plot1_data %>%
mutate(word = recode(word, '1' = "Primacy Items",
'2' = "Primacy Items",
'3' = "Primacy Items",
'4' = "Mid Items",
'5' = "Mid Items",
'6' = "Mid Items",
'7' = "Mid Items",
'8' = "Recency Items",
'9' = "Recency Items",
'10' = "Recency Items"))
plot3_data %<>%
group_by(word, bin, span_group) %>%
summarise(mean_TEPR = mean(TEPR, na.rm = TRUE),
se_TEPR = sundry::se(TEPR))
plot3 <- ggplot(plot3_data, aes(x = bin, y = mean_TEPR, colour = span_group)) +
geom_point(size = 0.8) +
# Generate outcome draws from a fitted model
stat_smooth_draws(times = 10,
aes(group = interaction(stat(.draw), colour)),
size = 0.8) +
scale_color_carto_d(palette = "Burg") +
# Create seperate plots for Primacy, Mid, and Recency Items
facet_wrap(~word) +
# Specifying sampled draws in addition to the animated lines
transition_states(stat(.draw), 1, 2) +
enter_fade() + exit_fade() +
shadow_mark(future = TRUE, size = 0.25, color = "gray50", alpha = 1/4) +
theme_minimal() +
# Rotate x axis values so they are angled; center subtitle
# Left-align caption
theme(axis.text.x = element_text(angle = 45, hjust = 1),
plot.caption = element_text(hjust = 0),
plot.subtitle = element_text(face = "bold", hjust = 0.5)) +
# Change labels
labs(caption = "Figure 3. Pupil diameter as a function of serial position and time across encoding period for low WMC (n = 31), medium WMC
(n = 69), and high WMC (n = 33) individuals. Serial position was broken down into Primacy (words 1–3), Mid (words 4–7),
and Recency (words 8–10) for graphical purposes only.",
y = "Mean Pupil Diameter (mm)",
x = "Time (ms)",
colour = "WMC") +
# Adjust/Relabel x axis values to make more sense to reader
scale_x_continuous(breaks = c(0, 2, 4, 6, 8, 10, 12, 14),
labels = c("0", "400", "800", "1,200",
"1,600", "2,000", "2,400","2,800"),
limits = c(0, NA)) +
# Adjust/Relabel y axis values to make more sense to reader
scale_y_continuous(breaks = c(-0.10, -0.05, 0.00, 0.05, 0.10, 0.15),
label = c("-0.10", "-0.05", "0.00",
"0.05", "0.10", "0.15"),
limits = c(-0.10, 0.15))
plot3 + bbg_darktheme
Above I faceted by serial position (primacy, mid, recency). In Miller et al. (2019), I actually faceted by WMC (low, mid, high). I honestly don’t know which method I prefer. For comparision sake, let’s try to reproduce the plot faceting by WMC:
- Remember, the point this graph is trying to make is that when instructed to study a list of words for a later test, two factors influence the trajectory of pupil dilation across the study phase: (1) one’s WMC and (2) serial position. For high WMC individuals, pupil dilation continues to gradually increase throughout the encoding period for all serial positions, with primacy items (the first few words presented during list presentation; words 1-3) displaying smaller dilations than mid (words 4–7) and recency items (the last few words presented during list presentation; words 8–10). Conversely, low WMC individuals show moderate increases in dilation that appear to plateau near the middle of the encoding period. Moreover, pupil dilation appears to be largest for primacy items and smallest for recency items, despite a gradual increase in dilation for recency items.
# Specify factor levels
plot3_data$word <- factor(plot3_data$word,
levels = c("Primacy Items",
"Mid Items",
"Recency Items"))
# Rename variables to enhance clarity
plot3_data %<>%
mutate(span_group = recode(span_group,
'Low' = "Low WMC",
'Medium' = "Medium WMC",
'High' = "High WMC"))
plot3.2 <- ggplot(plot3_data, aes(x = bin, y = mean_TEPR, colour = word)) +
geom_point(size = 0.8) +
# Generate outcome draws from a fitted model
stat_smooth_draws(times = 10,
aes(group = interaction(stat(.draw), colour)),
size = 0.8) +
scale_color_carto_d(palette = "Burg") +
# Create seperate plots for people with low, mid, and high WMC
facet_wrap(~span_group) +
# Specifying sampled draws in addition to the animated lines
transition_states(stat(.draw), 1, 2) +
enter_fade() + exit_fade() +
shadow_mark(future = TRUE, size = 0.25, color = "gray50", alpha = 1/4) +
theme_minimal() +
# Rotate x axis values so they are angled; center subtitle
# Left-align caption
theme(axis.text.x = element_text(angle = 45, hjust = 1),
plot.caption = element_text(hjust = 0),
plot.subtitle = element_text(face = "bold", hjust = 0.5)) +
# Change labels
labs(caption = "Figure 3. Pupil diameter as a function of serial position and time across encoding period for low WMC (n = 31), medium WMC
(n = 69), and high WMC (n = 33) individuals. Serial position was broken down into Primacy (words 1–3), Mid (words 4–7),
and Recency (words 8–10) for graphical purposes only.",
y = "Mean Pupil Diameter (mm)",
x = "Time (ms)",
colour = "Serial Position") +
# Adjust/Relabel x axis values to make more sense to reader
scale_x_continuous(breaks = c(0, 2, 4, 6, 8, 10, 12, 14),
labels = c("0", "400", "800", "1,200",
"1,600", "2,000", "2,400","2,800"),
limits = c(0, NA)) +
# Adjust/Relabel y axis values to make more sense to reader
scale_y_continuous(breaks = c(-0.10, -0.05, 0.00, 0.05, 0.10, 0.15),
label = c("-0.10", "-0.05", "0.00",
"0.05", "0.10", "0.15"),
limits = c(-0.10, 0.15))
plot3.2 + bbg_darktheme